home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / rzmac.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  3.8 KB  |  145 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module rzmac macro)
  13.  
  14. ;;;   *****************************************************************
  15. ;;;   ***** MACROS ******* ASSORTED MACROS FOR GENERAL REPRESENTATION *
  16. ;;;   *****************************************************************
  17.  
  18. (defmacro repeat (index limit . body)
  19.       `(do ((,index 0 (f1+ ,index)))
  20.           ((not (< ,index ,limit))) . ,body))
  21.  
  22. (defmacro logor (&rest frobs) `(boole  boole-ior . ,frobs))
  23.  
  24. (defmacro add-to-set (set frob)
  25.      `((lambda (temp)
  26.            (or (memq temp ,set)
  27.                (setq ,set (cons temp ,set))))
  28.        ,frob))
  29.  
  30. #+ITS
  31. (defmacro compiling ()
  32.       `(and (boundp 'compiler-state)
  33.         (not (eq compiler-state 'toplevel))))
  34. #-ITS
  35. (defmacro compiling nil t)
  36.  
  37.  
  38. ;(defun *bind* macro (l)
  39. ;(macro *bind* (l)
  40. ;       ((lambda (bindings body)
  41. ;        (nconc (list 'do (mapcar (fn (q)
  42. ;                         (cond ((atom q)
  43. ;                            (list q))
  44. ;                           ((eq (cadr q) '|<-|)
  45. ;                            (list (car q) (caddr q)))
  46. ;                           (t q)))
  47. ;                     bindings)
  48. ;                 nil)
  49. ;               (maplist (fn (x) (cond ((null (cdr x))
  50. ;                           (cons 'return x))
  51. ;                          ((car x))))
  52. ;                body)))
  53. ;    (cadr l) (cddr l)))
  54.                         
  55. (defmacro *bind* (bindings &body body)
  56.         (nconc (list 'do (mapcar (fn (q)
  57.                          (cond ((atom q)
  58.                             (list q))
  59.                            ((eq (cadr q) '|<-|)
  60.                             (list (car q) (caddr q)))
  61.                            (t q)))
  62.                      bindings)
  63.                  '(nil))
  64.                (maplist (fn (x) (cond ((null (cdr x))
  65.                            (cons 'return x))
  66.                           ((car x))))
  67.                 body)))
  68.  
  69.   
  70.  
  71.  
  72.  
  73. (defmacro displace2 (form new-car new-cdr)
  74.       `(rplaca (rplacd ,form ,new-cdr) ,new-car))
  75.  
  76. ;; Returns the negation of VALUE if PREDICATE is true.  Otherwise, just
  77. ;; returns VALUE.
  78.  
  79. (defmacro negate-if (predicate value &aux (temp (gensym)))
  80.       `(let ((,temp ,predicate))
  81.         (cond (,temp (neg ,value))
  82.               (t ,value))))
  83.  
  84. (defmacro either (which first second)
  85.       `(cond (,which ,first) (,second)))
  86.  
  87. ;; Setq's the first variable to VALUE if SWITCH is true, and sets the second
  88. ;; variable otherwise.
  89.  
  90. (defmacro set-either (first-var second-var switch value &aux (temp (gensym)))
  91.       `(let ((,temp ,value))
  92.         (cond (,switch (setq ,first-var ,temp))
  93.               (t (setq ,second-var ,temp)))))
  94.  
  95. #-cl ;;I could not find any callers of this thank god.
  96. (defmacro \* (&rest l) `(remainder . ,l))
  97.  
  98.  
  99. (comment Symbolic Arithmetic Macros)
  100.  
  101. (defmacro m+ (&rest body) `(add* . ,body))
  102.  
  103. (defmacro m* (&rest body) `(mul* . ,body))
  104.  
  105. (defmacro m1+ (x) `(add* 1 ,x))
  106.  
  107. (defmacro m1- (x) `(add* -1 ,x))
  108.  
  109. (defmacro m// (a1 &optional (a2 nil 2args))
  110.       (cond (2args `(div* ,a1 ,a2))
  111.         (t `(inv* ,a1))))
  112.  
  113. (defmacro m- (a1 &optional (a2 nil 2args))
  114.       (cond (2args `(sub* ,a1 ,a2))
  115.         (t `(mul* -1 ,a1))))
  116.  
  117. (defmacro m^ (b e) `(power* ,b ,e))
  118.  
  119. (defmacro m+l (l) `(addn ,l nil))
  120.  
  121. (defmacro m*l (l) `(muln ,l nil))
  122.  
  123. ;With 
  124. (defmacro m+t (&rest body) `(add . ,body))
  125.  
  126. (defmacro m*t (&rest body) `(mul . ,body))
  127.  
  128. (defmacro m1+t (x) `(add 1 ,x))
  129.  
  130. (defmacro m1-t (x) `(add -1 ,x))
  131.  
  132. (defmacro m//t (a1 &optional (a2 nil 2args))
  133.       (cond (2args `(div ,a1 ,a2))
  134.         (t `(inv ,a1))))
  135.  
  136. (defmacro m-t (a1 &optional (a2 nil 2args))
  137.       (cond (2args `(sub ,a1 ,a2))
  138.         (t `(neg ,a1))))
  139.  
  140. (defmacro m^t (b e) `(power ,b ,e))
  141.  
  142. (defmacro m+lt (l) `(addn ,l ,t))
  143.  
  144. (defmacro m*lt (l) `(muln ,l ,t))
  145.